home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / jock.zip / TOTSRC11.ZIP / TOTDATE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-04  |  16KB  |  615 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.10                             }
  6.  
  7. Unit totDATE;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes:
  12.            1.00a   ??/??/??   Corrected calc of Year
  13.            1.00b   06/01/91   Corrected 1.00a!
  14.            1.00c   02/03/92   Changed Leap Year validation
  15.            1.00d   02/27/92   Corrected DateFormat function
  16.            1.00e   03/09/92   Changed 1900+ operation for 0..99 years
  17.            1.10a   05/05/93   Changed ret value on JultoGreg and GregToStr
  18.                               when 0 values passed.
  19. }
  20.  
  21. INTERFACE
  22.  
  23. Uses DOS,totLOOK,totSTR;
  24.  
  25. Type
  26.  
  27. tDate = (MMDDYY,MMDDYYYY,MMYY,MMYYYY,DDMMYY,DDMMYYYY,YYMMDD,YYYYMMDD);
  28. StrShort = string[20];
  29.  
  30. tMonths  = array[1..12] of StrShort;
  31. tDays = array[0..6] of StrShort;
  32.  
  33. pDateOBJ = ^DateOBJ;
  34. DateOBJ = object
  35.    vLastYearNextCentury: byte;
  36.    vSeparator: char;
  37.    vMonths: tMonths;
  38.    vDays: tDays;
  39.    {methods...}
  40.    constructor Init;
  41.    procedure   SetLastYearNextCentury(Yr:byte);
  42.    procedure   SetSeparator(Sep:char);
  43.    procedure   SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: strshort);
  44.    procedure   SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:strshort);
  45.    function    GetLastYearNextCentury: byte;
  46.    function    GetSeparator: char;
  47.    function    GetMonth(Mth:byte):string;
  48.    function    GetDay(Day:byte):string;
  49.    destructor  Done;
  50. end; {DateOBJ}
  51.  
  52. function  GregtoJul(M,D,Y : longint): longint;
  53. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  54. function  Day(DStr:string;Format:tDate): word;
  55. function  Month(DStr:string;Format:tDate): word;
  56. function  Year(DStr:string;Format:tDate): word;
  57. function  StrtoJul(DStr:string;Format:tDate):longint;
  58. function  DOWStr(DStr:string;Format:tDate): byte;
  59. function  DOWJul(Jul:longint): byte;
  60. function  GregtoStr(M,D,Y:longint;Format:tDate): string;
  61. function  JultoStr(Jul:longint;Format:tDate): string;
  62. function  TodayinJul: longint;
  63. function  ValidDate(M,D,Y:longint):boolean;
  64. function  ValidDateStr(DStr:string;Format:tDate): boolean;
  65. function  StripDateStr(DStr:string;Format:tDate):string;
  66. function  FancyDateStr(Jul:longint; Long,Day:boolean): string;
  67. function  RelativeDate(DStr:string;Format:tDate;Delta:longint):string;
  68. function  StartOfYear(Jul:longint):longint;
  69. function  EndOfYear(Jul:longint):longint;
  70. function  DateFormat(Format:tDate):string;
  71. procedure DateInit;
  72.  
  73. var
  74.  
  75.   DateTOT: ^DateOBJ;
  76.  
  77. IMPLEMENTATION
  78.  
  79. {|||||||||||||||||||||||||||||||||||||||}
  80. {                                       }
  81. {     D a t e O B J   M E T H O D S     }
  82. {                                       }
  83. {|||||||||||||||||||||||||||||||||||||||}
  84. constructor DateOBJ.Init;
  85. {}
  86. begin
  87.    vLastYearNextCentury := 20;
  88.    vSeparator := '/';
  89.    SetDays('Sunday','Monday','Tuesday','Wednesday',
  90.            'Thursday','Friday','Saturday');
  91.    SetMonths('January','February','March','April','May',
  92.              'June','July','August','September',
  93.              'October','November','December');
  94. end; {DateOBJ.Init}
  95.  
  96. function DateOBJ.GetLastYearNextCentury: byte;
  97. {}
  98. begin
  99.    GetLastYearNextCentury := vLastYearNextCentury;
  100. end; {DateOBJ.GetLastYearNextCentury}
  101.  
  102. procedure DateOBJ.SetLastYearNextCentury(Yr:byte);
  103. {}
  104. begin
  105.    {$IFDEF CHECK}
  106.      if (Yr >= 0) and (Yr <= 99) then
  107.         vLastYearNextCentury := Yr;
  108.    {$ELSE}
  109.      vLastYearNextCentury := Yr;
  110.    {$ENDIF}
  111. end; {DateOBJ.GetLastYearNextCentury}
  112.  
  113. function DateOBJ.GetSeparator: char;
  114. {}
  115. begin
  116.    GetSeparator := vSeparator;
  117. end; {DateOBJ.GetSeparator}
  118.  
  119. procedure DateOBJ.SetSeparator(Sep:char);
  120. {}
  121. begin
  122.    vSeparator := Sep;
  123. end; {DateOBJ.SetSeparator}
  124.  
  125. procedure DateOBJ.SetMonths(Mth1,Mth2,Mth3,Mth4,Mth5,Mth6,Mth7,Mth8,Mth9,Mth10,Mth11,Mth12: StrShort);
  126. {}
  127. begin
  128.    vMonths[1] := Mth1;
  129.    vMonths[2] := Mth2;
  130.    vMonths[3] := Mth3;
  131.    vMonths[4] := Mth4;
  132.    vMonths[5] := Mth5;
  133.    vMonths[6] := Mth6;
  134.    vMonths[7] := Mth7;
  135.    vMonths[8] := Mth8;
  136.    vMonths[9] := Mth9;
  137.    vMonths[10] := Mth10;
  138.    vMonths[11] := Mth11;
  139.    vMonths[12] := Mth12;
  140. end; {DateOBJ.SetMonths}
  141.  
  142. procedure DateOBJ.SetDays(Day0,Day1,Day2,Day3,Day4,Day5,Day6:StrShort);
  143. {}
  144. begin
  145.    vDays[0] := Day0;
  146.    vDays[1] := Day1;
  147.    vDays[2] := Day2;
  148.    vDays[3] := Day3;
  149.    vDays[4] := Day4;
  150.    vDays[5] := Day5;
  151.    vDays[6] := Day6;
  152. end; {DateOBJ.SetDays}
  153.  
  154. function DateOBJ.GetMonth(Mth:byte):string;
  155. {}
  156. begin
  157.    if Mth in [2..12] then
  158.       GetMonth := vMonths[Mth]
  159.    else
  160.       GetMonth := vMonths[1];
  161. end; {DateOBJ.GetMonth}
  162.  
  163. function DateOBJ.GetDay(Day:byte):string;
  164. {}
  165. begin
  166.    if Day in [1..6] then
  167.       GetDay := vDays[Day]
  168.    else
  169.       GetDay := vDays[0];
  170. end; {DateOBJ.GetDay}
  171.  
  172. destructor DateOBJ.Done;
  173. begin end;
  174. {|||||||||||||||||||||||||||||||||||||||||||}
  175. {                                           }
  176. {     M i s c   P r o c   &   F u n c s     }
  177. {                                           }
  178. {|||||||||||||||||||||||||||||||||||||||||||}
  179. function PadDateStr(DStr:string;Format:tDate):string;
  180. {}
  181. var
  182.    Part1,Part2,Part3: string;
  183.    L,P: byte;
  184.    Sep1,Sep2:char;
  185.  
  186.      procedure PadOut(var S:string; width:byte);
  187.      begin
  188.         S := padright(S,width,'0');
  189.      end;
  190.  
  191. begin
  192.    if length(DStr) = length(DateFormat(Format)) then
  193.    begin
  194.       PadDateStr := DStr;
  195.       exit;
  196.    end;
  197.    P := 0;
  198.    L := length(DStr);
  199.    repeat
  200.       inc(P);
  201.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  202.    if P > L then
  203.    begin
  204.       PadDateStr := DStr;
  205.       exit;
  206.    end;
  207.    Part1 := copy(DStr,1,pred(P));
  208.    Sep1 := DStr[P];
  209.    delete(DStr,1,P);
  210.    P:= 0;
  211.    repeat
  212.       inc(P);
  213.    until (not (DStr[P] in ['0'..'9'])) or (P > L);
  214.    Part2 := copy(DStr,1,pred(P));
  215.    Sep2 := DStr[P];
  216.    Part3 := copy(DStr,succ(P),4);
  217.    case Format of
  218.       MMDDYY,YYMMDD,DDMMYY:begin
  219.           PadOut(Part1,2);
  220.           PadOut(Part2,2);
  221.           PadOut(Part3,2);
  222.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  223.       end;
  224.       MMDDYYYY,DDMMYYYY:begin
  225.           PadOut(Part1,2);
  226.           PadOut(Part2,2);
  227.           PadOut(Part3,4);
  228.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  229.       end;
  230.       YYYYMMDD:begin
  231.           PadOut(Part1,4);
  232.           PadOut(Part2,2);
  233.           PadOut(Part3,2);
  234.           DStr := Part1+Sep1+Part2+Sep2+Part3;
  235.       end;
  236.       MMYY:begin
  237.           PadOut(Part1,2);
  238.           PadOut(Part2,2);
  239.           DStr := Part1+Sep1+Part2;
  240.       end;
  241.       MMYYYY:begin
  242.           PadOut(Part1,2);
  243.           PadOut(Part2,4);
  244.           DStr := Part1+Sep1+Part2;
  245.       end;
  246.    end; {case}
  247.    PadDateStr := DStr;
  248. end; {PadDateStr}
  249.  
  250. function GregtoJul(M,D,Y:longint):longint;
  251. {}
  252. var Factor: integer;
  253. begin
  254.    if M < 3 then
  255.       Factor := -1
  256.    else
  257.       Factor := 0;
  258.    GregtoJul :=  (1461*(Factor+4800+Y) div 4)
  259.                + ((M-2-(Factor*12))*367) div 12
  260.                - (3*((Y+4900+Factor) div 100) div 4)
  261.                + D
  262.                - 32075;
  263. end; {GregtoJul}
  264.  
  265. procedure JultoGreg(Jul:longint; var M,D,Y: longint);
  266. {}
  267. var U,V,W,X: longint;
  268. begin
  269.    if Jul = 0 then {1.10a}
  270.    begin
  271.       M := 0;
  272.       D := 0;
  273.       Y := 0;
  274.    end
  275.    else
  276.    begin
  277.       inc(Jul,68569);
  278.       W := (Jul*4) div 146097;
  279.       dec(Jul,((146097*W)+3) div 4);
  280.       X := 4000*succ(Jul) div 1461001;
  281.       dec(Jul,((1461*X) div 4) - 31);
  282.       V := 80*Jul div 2447;
  283.       U := V div 11;
  284.       D := Jul - (2447*V div 80);
  285.       M := V + 2 - (U*12);
  286.       Y := X + U + (W-49)*100;
  287.    end;
  288. end; {JultoGreg}
  289.  
  290. function Day(DStr:string;Format:tDate): word;
  291. {}
  292. var
  293.    DayStr: string;
  294. begin
  295.    DStr := PadDateStr(DStr,Format);
  296.    case Format of
  297.       MMDDYY,
  298.       MMDDYYYY: DayStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  299.       DDMMYY,
  300.       DDMMYYYY: DayStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  301.       YYMMDD:   DayStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  302.       YYYYMMDD: DayStr := NthNumber(DStr,7)+NthNumber(DStr,8);
  303.       else     DayStr := '01';
  304.    end; {case}
  305.    Day := StrToInt(DayStr);
  306. end; {Day}
  307.  
  308. function Month(DStr:string;Format:tDate): word;
  309. {}
  310. var
  311.    MonStr: string;
  312. begin
  313.    DStr := PadDateStr(DStr,Format);
  314.    case Format of
  315.       MMDDYY,
  316.       MMDDYYYY,
  317.       MMYY,
  318.       MMYYYY  :  MonStr := NthNumber(DStr,1)+NthNumber(DStr,2);
  319.       YYMMDD,
  320.       DDMMYY,
  321.       DDMMYYYY:  MonStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  322.       YYYYMMDD:  MonStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  323.    end; {case}
  324.    Month := StrToInt(MonStr);
  325. end; {Month}
  326.  
  327. function Year(DStr:string;Format:tDate): word;
  328. {}
  329. var
  330.    YrStr: string;
  331.    TmpYr: word;
  332. begin
  333.    DStr := PadDateStr(DStr,Format);
  334.    Case Format of
  335.       MMDDYY,
  336.       DDMMYY   : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6);
  337.       MMDDYYYY,
  338.       DDMMYYYY : YrStr := NthNumber(DStr,5)+NthNumber(DStr,6)
  339.                           + NthNumber(DStr,7)+NthNumber(DStr,8);
  340.       MMYY     : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4);
  341.       MMYYYY   : YrStr := NthNumber(DStr,3)+NthNumber(DStr,4)
  342.                           + NthNumber(DStr,5)+NthNumber(DStr,6);
  343.       YYMMDD   : YrStr := NthNumber(DStr,1)+NthNumber(DStr,2);    {5.00a and b}
  344.       YYYYMMDD : YrStr := NthNumber(DStr,1)+NthNumber(DStr,2)
  345.                           + NthNumber(DStr,3)+NthNumber(DStr,4);
  346.    end;
  347.    TmpYr := StrToInt(YrStr);
  348.    if (TmpYr >= 0) and (TmpYr <= 99) and (length(YrStr) <= 2) then {1.00e}
  349.    begin
  350.       if TmpYr < DateTOT^.GetLastYearNextCentury then
  351.          TmpYr := 2000 + TmpYr
  352.       else
  353.          TmpYr := 1900 + TmpYr;
  354.    end;
  355.    Year := TmpYr;
  356. end; {Year}
  357.  
  358. function GregtoStr(M,D,Y:longint;Format:tDate): string;  {1.10a}
  359. {}
  360. var
  361.    PadChar : char;
  362.    DD,MM: string[2];
  363.    YY: string[4];
  364. begin
  365.    PadChar := DateTOT^.GetSeparator;
  366.    if D < 1 then
  367.       DD := '∙∙'
  368.    else
  369.    begin
  370.       DD := InttoStr(D);
  371.       if D < 10 then
  372.          DD := '0'+DD;
  373.    end;
  374.    if M < 1 then
  375.       MM := '∙∙'
  376.    else
  377.    begin
  378.       MM := InttoStr(M);
  379.       if M < 10 then
  380.          MM := '0'+MM;
  381.    end;
  382.    if (Format in [MMDDYY,MMYY,DDMMYY,YYMMDD])
  383.    and ((Y > 99) or (Y < -99)) then
  384.       Y := Y Mod 100;
  385.    if Y = 0 then
  386.       YY := '∙∙'
  387.    else
  388.    begin
  389.       YY := InttoStr(Y);
  390.       if Y < 10 then
  391.          YY := '0'+YY;
  392.    end;
  393.    Case Format of
  394.       MMDDYY,
  395.       MMDDYYYY: GregtoStr := MM+PadChar+DD+Padchar+YY;
  396.       MMYY,
  397.       MMYYYY  : GregtoStr := MM+Padchar+YY;
  398.       DDMMYY,
  399.       DDMMYYYY: GregtoStr := DD+PadChar+MM+Padchar+YY;
  400.       YYMMDD,
  401.       YYYYMMDD: GregtoStr := YY+PadChar+MM+Padchar+DD;
  402.    end; {case}
  403. end; {GregtoStr}
  404.  
  405. function JultoStr(Jul:longint;Format:tDate): string;
  406. {}
  407. var M,D,Y:longint;
  408. begin
  409.    JultoGreg(Jul,M,D,Y);
  410.    JultoStr := GregtoStr(M,D,Y,Format);
  411. end; {JultoStr}
  412.  
  413. function TodayinJul: longint;
  414. {}
  415. var 
  416.  M,D,Y,DOW: word;
  417. begin
  418.    GetDate(Y,M,D,DOW);
  419.    TodayinJul := GregtoJul(M,D,Y);
  420. end; {TodayinJul}
  421.  
  422. function LeapYear(Y:longint):boolean;
  423. {}
  424. begin
  425.    LeapYear := (Y mod 4 = 0) and ((Y mod 400 = 0) or (Y mod 100 <> 0));
  426. end; {LeapYear}
  427.  
  428. function ValidDate(M,D,Y:longint):boolean;
  429. {}
  430. begin
  431.    if (D < 1)
  432.    or (D > 31)
  433.    or (M < 1)
  434.    or (M > 12)
  435.    then 
  436.       ValidDate := False
  437.    else
  438.       Case M of
  439.          4,6,9,11: ValidDate := (D <= 30);
  440.          2:        ValidDate := (D <= 28)
  441.                                 or ( (D = 29) and LeapYear(Y)); {1.00c}
  442.           else ValidDate := true;
  443.       end; {case}
  444. end; {ValidDate}
  445.  
  446. function  ValidDateStr(DStr:string;Format:tDate): boolean;
  447. {}
  448. var
  449.  M,D,Y: word;
  450. begin
  451.    M := Month(DStr,Format);
  452.    D := Day(DStr,Format);
  453.    Y := Year(DStr,Format);
  454.    ValidDateStr := ValidDate(M,D,Y);
  455. end; {ValidDateStr}
  456.  
  457. function DOWJul(Jul:longint): byte;
  458. var M,D,Y,N: longint;
  459. begin
  460.    JultoGreg(Jul,M,D,Y);
  461.    if M <=2 then
  462.      N := 1461 * (Y-1) div 4 + 153 * (M+13) div 5 + D
  463.    else
  464.      N := 1461 * Y div 4 + 153 * (M+1) div 5 + D;
  465.    N:= abs((N - 621049)) mod 7;
  466.    DOWJul := N;
  467. end; {DayOfWeek}
  468.  
  469. function StrtoJul(DStr:string;Format:tDate):longint;
  470. {}
  471. var
  472.   M,D,Y:longint;
  473. begin
  474.    M := Month(Dstr,Format);
  475.    D := Day(Dstr,Format);
  476.    Y := Year(Dstr,Format);
  477.    StrtoJul := GregtoJul(M,D,Y);
  478. end; {StrtoJul}
  479.  
  480. function DOWStr(DStr:string;Format:tDate): byte;
  481. {}
  482. begin
  483.    DOWStr := DOWJul(StrtoJul(Dstr,Format));
  484. end; {DOWStr}
  485.  
  486. function StripDateStr(DStr:string;Format:tDate):string;
  487. {}
  488. begin
  489.    case Format of
  490.       MMDDYY,
  491.       MMDDYYYY,
  492.       DDMMYY,
  493.       DDMMYYYY,
  494.       YYMMDD: begin
  495.                  delete(Dstr,3,1);
  496.                  delete(Dstr,5,1);
  497.               end;
  498.       MMYY,
  499.       MMYYYY  : delete(DStr,3,1);
  500.       YYYYMMDD: begin
  501.                   delete(DStr,5,1);
  502.                   delete(DStr,7,1);
  503.                 end;
  504.    end; {case}
  505.    StripDateStr := DStr;
  506. end; {StripDateStr}
  507.  
  508. function FancyDateStr(Jul:longint; Long,Day:boolean): string;
  509. {}
  510. var 
  511.   M,D,Y:longint;
  512.   TheDay: byte;
  513.   Str: string;
  514. begin
  515.    JultoGreg(Jul,M,D,Y);
  516.    Str := ' '+InttoStr(D)+', '+IntToStr(Y);
  517.    if Long then
  518.       Str := dateTOT^.GetMonth(M) + Str
  519.    else
  520.       Str := copy(dateTOT^.GetMonth(M),1,3) + Str;
  521.    if Day then
  522.    begin
  523.       TheDay := DOWJul(Jul);
  524.       if Long then
  525.          Str := dateTOT^.GetDay(TheDay) + ' ' + Str
  526.       else
  527.          Str := copy(dateTOT^.GetDay(TheDay),1,3) + ' ' + Str;
  528.    end;
  529.    FancyDateStr := Str;
  530. end; {FancyDateStr}
  531.  
  532. function RelativeDate(DStr:string;Format:tDate;Delta:longint):string;
  533. {}
  534. begin
  535.    RelativeDate := JultoStr(StrtoJul(DStr,Format)+Delta,Format);
  536. end; {RelativeDate}
  537.  
  538. function EndOfMonth(Jul:longint):longint;
  539. {}
  540. var M,D,Y:longint;
  541. begin
  542.    JultoGreg(Jul,M,D,Y);
  543.    case M of
  544.       4,6,9,11: D := 30;
  545.       2: if (Y mod 4 = 0) and (Y <> 0) and (Y <> 1900) then
  546.             D := 29
  547.          else
  548.             D := 28;
  549.       else D := 31;
  550.    end; {case}
  551.    EndOfMonth := GregtoJul(M,D,Y);
  552. end; {EndOfMonth}
  553.  
  554. function StartOfMonth(Jul:longint):longint;
  555. {}
  556. var M,D,Y:longint;
  557. begin
  558.    JultoGreg(Jul,M,D,Y);
  559.    StartOfMonth := GregtoJul(M,1,Y);
  560. end; {StartOfMonth}
  561.  
  562. function StartOfYear(Jul:longint):longint;
  563. {}
  564. var M,D,Y:longint;
  565. begin
  566.    JultoGreg(Jul,M,D,Y);
  567.    StartOfYear := GregtoJul(1,1,Y);
  568. end; {StartOfYear}
  569.  
  570. function EndOfYear(Jul:longint):longint;
  571. {}
  572. var M,D,Y:longint;
  573. begin
  574.    JultoGreg(Jul,M,D,Y);
  575.    EndOfYear := GregtoJul(12,31,Y);
  576. end; {EndOfYear}
  577.  
  578. function DateFormat(Format:tDate):string;
  579. {}
  580. var Sep:char;
  581. begin
  582.    Sep := DateTOT^.GetSeparator;
  583.    Case Format of
  584.       MMDDYY: DateFormat := 'MM'+Sep+'DD'+Sep+'YY';
  585.       MMDDYYYY: DateFormat := 'MM'+Sep+'DD'+Sep+'YYYY';
  586.       MMYY: DateFormat := 'MM'+Sep+'YY';
  587.       MMYYYY: DateFormat := 'MM'+Sep+'YYYY';
  588.       DDMMYY: DateFormat := 'DD'+Sep+'MM'+Sep+'YY';   {1.00d}
  589.       DDMMYYYY: DateFormat := 'DD'+Sep+'MM'+Sep+'YYYY';
  590.       YYMMDD: DateFormat := 'YY'+Sep+'MM'+Sep+'DD';
  591.       YYYYMMDD: DateFormat :=  'YYYY'+Sep+'MM'+Sep+'DD'; {1.00d}
  592.    end; {case}
  593. end; {DateFormat}
  594. {|||||||||||||||||||||||||||||||||||||||||||||||}
  595. {                                               }
  596. {     U N I T   I N I T I A L I Z A T I O N     }
  597. {                                               }
  598. {|||||||||||||||||||||||||||||||||||||||||||||||}
  599.  
  600. procedure DateInit;
  601. {initilizes objects and global variables}
  602. begin
  603.    new(DateTOT,Init);
  604. end; {DateInit}
  605.  
  606. {end of unit - add initialization routines below}
  607. {$IFNDEF OVERLAY}
  608. begin
  609.    DateInit;
  610. {$ENDIF}
  611. end.
  612.  
  613.  
  614.  
  615.